;;;;;;;;;;;;;;;;;;;;;;;;;;;
; COMMUNICATION BEHAVIOUR ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass communicator (remote-object)
  ((channels :initform nil :accessor communicator-channels)
   (any-discovery-observers :initform nil :accessor communicator-any-discovery-observers)))

(defmethod start-communication (communicator)
  (comm:start-up-server 
   :function (lambda (port)
               ;(debug-print "connection requested" port)
               (let ((stream (make-instance 'comm:socket-stream :socket port
                                            :direction :io :element-type 'base-char)))
                 (mp:process-run-function (format nil "communication-server-~D" port)
                  '()
                  'read-message-from-stream communicator stream)))
   :service *device-port*))

(defun read-message-from-stream (communicator stream)
  ;(debug-print "reading message from" stream)
  (unwind-protect
      (with-standard-io-syntax
        (let* ((*package* (find-package 'closer-common-lisp-user))
               (message (read stream))
               (actor (remote-object-actor (message-receiver message))))
          ;(debug-print "receiving message" (function-call-name (message-function-call message)))
          ;(debug-print "receiver" (message-receiver message))
          ;(write message :stream *screen-output* :escape t :readably t)
          ;(finish-output *screen-output*)
          (receive-message actor message)))
    (close stream)))

(defmethod add-channel (communicator channel)
  (push channel (communicator-channels communicator))
  (make-actor (generate-new-actor-name) channel))

(defmethod service-connected (communicator service-description remote-reference)
  (let ((channel (find-unconnected-channel communicator service-description)))
    (cond (channel (send channel (connect channel remote-reference)))
          (t (setf channel (make-instance 'channel
                                          :service-description service-description
                                          :remote-reference remote-reference))
             (add-channel communicator channel)
             (notify-any-discovery-observers communicator channel service-description)))))

(defmethod service-disconnected (communicator remote-reference)
  (let ((channel (find-channel-with-object-name communicator (remote-reference-object-name remote-reference))))
    (when channel
      (send channel (disconnect channel)))))

(defmethod transmit-message (communicator message)
  (let ((channel (find-channel-with-object-name communicator
                                                (remote-reference-object-name (message-receiver message)))))
    (unless channel
      (setf channel (make-instance 'channel :remote-reference (message-receiver message)))
      (add-channel communicator channel))
    (send channel (transmit channel message) nil)))

(defmethod add-any-discovery-observer (communicator observer service-description)
  (push (cons service-description observer) (communicator-any-discovery-observers communicator)))

(defmethod notify-any-discovery-observers (communicator channel service-description)
  (loop for observer-cons in (reverse (communicator-any-discovery-observers communicator))
        do (when (equal (car observer-cons) service-description)
             ; This should be an asynchronous call but since we need to ensure that this happens before
             ; the call made after the loop... we assume the consequences (none, so far).
             ; (send (cdr observer-cons) (resolve-with-result (cdr observer-cons) channel))
             (resolve-with-result (cdr observer-cons) channel))))

(defmethod find-unconnected-channel (communicator service-description)
  (dolist (channel (communicator-channels communicator))
    (when (slot-boundp channel 'service-description)
      (when (and (equal service-description (channel-service-description channel))
                 (not (slot-boundp channel 'remote-reference)))
        (return channel)))))

(defmethod find-channel-with-object-name (communicator object-name)
  (find object-name (communicator-channels communicator)
        :test #'equal
        :key (lambda (channel) (remote-reference-object-name (channel-remote-reference channel)))))

;;;;;;;;;;;;
; CHANNELS ;
;;;;;;;;;;;;
(defclass channel (remote-object)
  ((service-description :initarg :service-description :accessor channel-service-description)
   (remote-reference :initarg :remote-reference :accessor channel-remote-reference)
   (discoveredp :initform nil :accessor channel-discoveredp)
   (message-queue :initform nil :accessor channel-message-queue)
   (discovery-observers :initform nil :accessor channel-discovery-observers)
   (disconnection-observers :initform nil :accessor channel-disconnection-observers)
   (reconnection-observers :initform nil :accessor channel-reconnection-observers)))

(defmethod queue-message (channel message)
  (push message (channel-message-queue channel)))

(defmethod transmit-queued-messages (channel)
  (loop for message in (reverse (channel-message-queue channel))
        do (transmit channel message)))

(defmethod transmit :around (channel message)
  (if (slot-boundp channel 'remote-reference)
      (call-next-method)
    (queue-message channel message)))

(defmethod transmit (channel message)
  (with-standard-io-syntax
    (let ((*package* (find-package 'closer-common-lisp-user))
          (*print-circle* t))
      (with-open-stream (stream (comm:open-tcp-stream (remote-reference-address (channel-remote-reference channel)) 
                                                      (remote-reference-port (channel-remote-reference channel))))
        (write message :stream stream :escape t :readably t)
        (force-output stream)))))

(defmethod connect (channel remote-reference)
  (setf (channel-remote-reference channel) remote-reference)
  (transmit-queued-messages channel)
  (if (channel-discoveredp channel)
      (notify-observers channel (channel-reconnection-observers channel))
    (notify-discovery-observers channel)))

(defmethod disconnect (channel)
  (slot-makunbound channel 'remote-reference)
  (notify-observers channel (channel-disconnection-observers channel)))

(defmethod notify-observers (channel observers)
  (loop for observer in (reverse observers)
        do (send observer (resolve-with-result observer channel))))

(defmethod notify-discovery-observers (channel)
  (setf (channel-discoveredp channel) t)
  (notify-observers channel (channel-discovery-observers channel)))

(defmethod add-discovery-observer (channel observer)
  (push observer (channel-discovery-observers channel))
  (when (slot-boundp channel 'remote-reference)
      (notify-discovery-observers channel)))

(defmethod add-disconnection-observer (channel observer)
  (push observer (channel-disconnection-observers channel)))

(defmethod add-reconnection-observer (channel observer)
  (push observer (channel-reconnection-observers channel)))

(defmethod print-object ((object channel) stream)
  (if *print-readably*
      (print (channel-remote-reference object) stream)
    (call-next-method)))

; TO-IMPROVE, tricky
(defmethod meta-messagep (channel method-name)
  (let ((method-list (list 'TRANSMIT 'QUEUE-MESSAGE 'TRANSMIT-QUEUED-MESSAGES 'CONNECT 'DISCONNECT
                           'NOTIFY-OBSERVERS 'NOTIFY-DISCOVERY-OBSERVERS 'ADD-DISCOVERY-OBSERVER
                           'ADD-DISCONNECTION-OBSERVER 'ADD-RECONNECTION-OBSERVER 'PRINT-OBJECT)))
    (find method-name method-list :test #'equal)))

;;;;;;;;;;;;;;;;;;;
; ACTOR EXTENSION ;
;;;;;;;;;;;;;;;;;;;
; send-message method definition that specialises over channels
(defmethod send-message ((this-actor actor-behaviour) (receiver channel) function-call future)
  (let ((message (make-message :sender this-actor :receiver receiver
                               :function-call function-call :future future)))
    (if (meta-messagep receiver (function-call-name function-call))
        (receive-message (remote-object-actor receiver) message)
      (send receiver (transmit receiver message) nil))
    future))

; INITIALISE *communication-actor*
(setf *communication-actor* (make-instance 'communicator))
(make-actor "communication" *communication-actor*)
(start-communication *communication-actor*)